home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pseudo-s / pseudo_2.lha / list.scm < prev    next >
Encoding:
Text File  |  1991-06-11  |  1.4 KB  |  58 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2. ; File list.scm / Copyright (c) 1991 Jonathan Rees / See file COPYING
  3.  
  4. ;;;; List utilities
  5.  
  6. (define (some pred l)
  7.   (and (not (null? l))
  8.        (or (pred (car l)) (some pred (cdr l)))))
  9.  
  10. (define (every pred l)
  11.   (or (null? l)
  12.       (and (pred (car l)) (every pred (cdr l)))))
  13.  
  14. (define (rassq obj lst)
  15.   (cond ((null? lst) #f)
  16.     ((eq? obj (cdar lst)) (car lst))
  17.     (else (rassq obj (cdr lst)))))
  18.  
  19. (define (filter pred l)
  20.   (cond ((null? l) '())
  21.     ((pred (car l)) (cons (car l) (filter pred (cdr l))))
  22.     (else (filter pred (cdr l)))))
  23.  
  24. (define (right-reduce proc lst identity)
  25.   (cond ((null? lst) identity)
  26.     (else (right-reduce proc (cdr lst) (proc (car lst) identity)))))
  27.  
  28. (define reduce right-reduce)
  29.  
  30. ; Set utilities
  31.  
  32. (define (setdiffq l1 l2)
  33.   (cond ((null? l2) l1)
  34.     ((null? l1) l1)
  35.     ((memq (car l1) l2)
  36.      (setdiffq (cdr l1) l2))
  37.     (else (cons (car l1)
  38.             (setdiffq (cdr l1) l2)))))
  39.  
  40. (define (unionq l1 l2)
  41.   (cond ((null? l1) l2)
  42.     ((null? l2) l1)
  43.     ((memq (car l1) l2) (unionq (cdr l1) l2))
  44.     (else (cons (car l1) (unionq (cdr l1) l2)))))
  45.  
  46. (define (intersectq l1 l2)
  47.   (cond ((null? l1) l1)
  48.     ((null? l2) l2)
  49.     ((memq (car l1) l2)
  50.      (cons (car l1) (intersectq (cdr l1) l2)))
  51.     (else (intersectq (cdr l1) l2))))
  52.  
  53. (define (intersectq? l1 l2)
  54.   (and (not (null? l1))
  55.        (not (null? l2))
  56.        (or (memq (car l1) l2)
  57.        (intersectq? (cdr l1) l2))))
  58.